home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0136_Stars AGAIN!!!!.pas < prev    next >
Pascal/Delphi Source File  |  1994-08-25  |  4KB  |  139 lines
  1. {
  2. Ok...  Here goes.  You will have to figure out how to TSR this if you
  3. want...  But you can navigate in this one too!  TP v6.0
  4. }
  5.  
  6. program stars;
  7. {$R-}
  8. {$S-}    {dangerous, but it's pretty well debugged}
  9. {$G+}
  10. uses crt;
  11. const MaxStars=1000;         { OK for 486-33. Decrease for slower computers}
  12.       xltsin:integer=0;
  13.       xltcos:integer=round((1-(640/32767)*(640/32767))*32767);
  14.       yltsin:integer=0;
  15.       yltcos:integer=round((1-(640/32767)*(640/32767))*32767);
  16.       zltsin:integer=0;
  17.       zltcos:integer=round((1-(640/32767)*(640/32767))*32767);
  18.                 {rotation parameters, 16-bit.}
  19.       speed:word=264;    {speed of movement thru starfield}
  20. const XWIDTH = 320;  { basic screen size stuff used for star animation.}
  21. const YWIDTH = 200;
  22. const XCENTER = ( XWIDTH div 2 );
  23. const YCENTER = ( YWIDTH div 2 );
  24. type STARtype=record
  25.                 x,y,z:integer; {The x, y and z coordinates}
  26.                 xz,yz:integer; { screen coords}
  27.               end;
  28. var star:array[1..maxstars] of startype;
  29.     i:integer;
  30.     ch:char;
  31.     rotx,roty,rotz:boolean;
  32.     rotxv,rotyv,rotzv:integer;
  33. procedure setmode13;    {sets 320*200 256-colour mode}
  34. assembler;
  35. asm
  36.   mov ax,13h
  37.   int 10h
  38. end;
  39. procedure settextmode;   {returns to text mode}
  40. assembler;
  41. asm
  42.   mov ax,03h
  43.   int 10h
  44. end;
  45. procedure setpix(x,y:integer;c:byte);  {NO BOUNDARY CHECKING!}
  46. begin   {Sets a pixel in mode 13h}
  47. asm
  48.   mov ax,0a000h
  49.   mov es,ax
  50.   mov ax,y
  51.   mov bx,320
  52.   mul bx
  53.   mov di,x
  54.   add di,ax
  55.   mov al,c
  56.   mov es:[di],al
  57. end;
  58. end;
  59. procedure initstar(i:integer);  {initialise stars at random positions}
  60. begin
  61.   with star[i] do
  62.   begin
  63.     x := longint(-32767)+random(65535);
  64.     y := longint(-32767)+random(65535);             {at rear}
  65.     z := random(16000)+256;
  66.     xz:=xcenter;
  67.     yz:=ycenter;
  68.   end;
  69. end;
  70. procedure newstar(i:integer);   {create new star at either front or}
  71. begin                            {rear of starfield}
  72.   with star[i] do
  73.   begin
  74.     x := longint(-32767)+random(65535);
  75.     y := longint(-32767)+random(65535);
  76.     if z<256 then z := random(1256)+14500     {kludgy, huh?}
  77.       else z:=random(256)+256;
  78.     xz:=xcenter;
  79.     yz:=ycenter;
  80.   end;
  81. end;
  82.  
  83. {$L update.obj}
  84. procedure update(var star:startype;i:integer);external;
  85.  
  86.  
  87.  
  88.  
  89. begin
  90.    {gets ~100 frames/sec on a 486-33 with 500 stars,
  91.        rotating on 1 axis, speed 256}
  92.   clrscr;
  93.   checkbreak:=false;                      { for speed?}
  94.   randomize;
  95.   for i:=1 to maxstars do initstar(i);    {initialise stars}
  96.   setmode13;
  97.   rotx:=true;roty:=true;rotz:=true;
  98.   ch:=' ';
  99.   repeat
  100.     for i:=1 to maxstars do update(star[i],i);  {update star positions}
  101.     if keypressed then
  102.     begin
  103.       ch:=readkey;                       { change parameters according to }
  104.       if ch='+' then speed:=speed+32;    {  key pressed}
  105.       if ch='-' then speed:=speed-32;
  106.       if ch=#13 then
  107.          begin
  108.               xltsin:=0;
  109.               yltsin:=0;
  110.               zltsin:=0;
  111.               speed:=256;
  112.          end;
  113.       if ch=#80 then dec(xltsin,96);
  114.       if ch=#72 then inc(xltsin,96);
  115.       if ch=#77 then dec(yltsin,96);
  116.       if ch=#75 then inc(yltsin,96);
  117.       if ch=#81 then
  118.          begin
  119.               dec(yltsin,96);
  120.               if xltsin<0 then inc(zltsin,96);
  121.               if xltsin>0 then dec(zltsin,96);
  122.          end;
  123.       if ch=#79 then
  124.          begin
  125.               inc(yltsin,96);
  126.               if xltsin<0 then dec(zltsin,96);
  127.               if xltsin>0 then inc(zltsin,96);
  128.          end;
  129.       if ch=#71 then dec(zltsin,96);
  130.       if ch=#73 then inc(zltsin,96);
  131.       end;
  132.     xltcos:=round((1-sqr(xltsin/32767))*32767);
  133.     yltcos:=round((1-sqr(yltsin/32767))*32767);    { evaluate cos values}
  134.     zltcos:=round((1-sqr(zltsin/32767))*32767);
  135.   until ch=#27;       {hit ESC to exit}
  136.   settextmode;
  137.   writeln;
  138. end.
  139.